{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit MatchQuestion;

interface

uses
  Classes, SysUtils, MiscUtils, Math, TestCore, SecureRandom, Pad, TestUtils;

type
  TMatchResponse = class(TResponse)
  private
    FAnswer: TIntegerArray;
  public
    procedure SetAnswer(const Value: TIntegerArray);
    function GetAnswer: TIntegerArray;
    procedure Assign(Source: TResponse); override;
  end;

  TMatchQuestion = class(TQuestionWithFormulation)
  private
    FLeft: TPadGroup;
    FRight: TPadGroup;
    FPairLimit: Integer; { 0 = all }
    FDistractorLimit: Integer; { 0 = include all items from the right,
                                -1 = don't include distractors }
    procedure SetDistractorLimit(Value: Integer);
    procedure SetPairLimit(Value: Integer);
  public
    constructor Create; override;
    destructor Destroy; override;
    class function GetResponseClass: TResponseClass; override;
    class procedure Spawn(var Question: TQuestion; Alterants: TAlterantList); override;
    class function Kind: TKind; override;
    function IsResponseCompatible(Candidate: TResponse): Boolean; override;
    function Evaluate(Candidate: TResponse): Single; override;
    procedure Filter; override;
    procedure Assign(Source: TQuestion); override;
    function ReplaceString(const OldString, NewString: String): Integer; override;
    function Response: TMatchResponse;

    property DistractorLimit: Integer read FDistractorLimit write SetDistractorLimit;
    property Left: TPadGroup read FLeft;
    property PairLimit: Integer read FPairLimit write SetPairLimit;
    property Right: TPadGroup read FRight;
  end;

  TSpawnMatchQuestionAlterant = class(TAlterant)
  private
    FLeftPlacement: TIntegerArray;
    FRightPlacement: TIntegerArray;
  public
    procedure Apply(var Question: TQuestion); override;
    function GetLeftPlacement: TIntegerArray;
    function GetRightPlacement: TIntegerArray;
    procedure SetLeftPlacement(const Value: TIntegerArray);
    procedure SetRightPlacement(const Value: TIntegerArray);
  end;

implementation

type
  TOfferedRightItem = class
  private
    FDisplayIndex: Integer;
    FItemIndex: Integer; { negative for distractors }
  public
    constructor Create(DisplayIndex, ItemIndex: Integer);
  end;
  TOfferedRightItemList = TGenericObjectList<TOfferedRightItem>;

{ TOfferedRightItem }

constructor TOfferedRightItem.Create(DisplayIndex, ItemIndex: Integer);
begin
  inherited Create;
  FDisplayIndex := DisplayIndex;
  FItemIndex := ItemIndex;
end;

{ TMatchQuestion }

constructor TMatchQuestion.Create;
begin
  inherited;
  FLeft := TPadGroup.Create;
  FRight := TPadGroup.Create;
end;

destructor TMatchQuestion.Destroy;
begin
  FreeAndNil(FLeft);
  FreeAndNil(FRight);
  inherited;
end;

function TMatchQuestion.IsResponseCompatible(
  Candidate: TResponse): Boolean;
var
  Answer: TIntegerArray;
  RightItemUsed: array of Boolean;
  i, n: Integer;
begin
  Result := Candidate is TMatchResponse;
  if Result then
  begin
    Answer := TMatchResponse(Candidate).GetAnswer;
    Result := Length(Answer) = Length(Response.GetAnswer);
    if Result then
    begin
      SetLength(RightItemUsed, Right.Count);
      for i := 0 to High(RightItemUsed) do
        RightItemUsed[i] := FALSE;

      for i := 0 to High(Answer) do
      begin
        n := Answer[i];
        if (n < -1) or (n >= Right.Count) then
        begin
          Result := FALSE;
          Break;
        end
        else if n >= 0 then
        begin
          if RightItemUsed[n] then
          begin
            Result := FALSE;
            Break;
          end
          else
            RightItemUsed[n] := TRUE;
        end;
      end;
    end;
  end;
end;

function TMatchQuestion.Evaluate(Candidate: TResponse): Single;
var
  CandidateAnswer: TIntegerArray;
begin
  CheckResponseCompatible(Candidate);
  CandidateAnswer := TMatchResponse(Candidate).GetAnswer;
  if LaxEvaluation then
    Result := EvaluateMappingLaxly(Response.GetAnswer, CandidateAnswer)
  else
    Result := EvaluateMappingDichotomically(Response.GetAnswer, CandidateAnswer);
end;

procedure TMatchQuestion.Filter;
var
  NullAnswer: TIntegerArray;
  i: Integer;
begin
  inherited;
  SetLength(NullAnswer, Length(Response.GetAnswer));
  for i := 0 to High(NullAnswer) do
    NullAnswer[i] := -1;
  Response.SetAnswer(NullAnswer);

  PairLimit := 0;
  DistractorLimit := 0;
end;

procedure TMatchQuestion.Assign(Source: TQuestion);
var
  q: TMatchQuestion;
begin
  inherited;
  q := Source as TMatchQuestion;

  FLeft.Assign(q.FLeft);
  FRight.Assign(q.FRight);

  FPairLimit := q.FPairLimit;
  FDistractorLimit := q.FDistractorLimit;
end;

function TMatchQuestion.Response: TMatchResponse;
begin
  Result := TMatchResponse(inherited);
end;

class function TMatchQuestion.GetResponseClass: TResponseClass;
begin
  Result := TMatchResponse;
end;

function TMatchQuestion.ReplaceString(const OldString,
  NewString: String): Integer;
begin
  Result := inherited;
  Inc(Result, FLeft.ReplaceString(OldString, NewString));
  Inc(Result, FRight.ReplaceString(OldString, NewString));
end;

procedure TMatchQuestion.SetDistractorLimit(Value: Integer);
begin
  Assert( Value >= -1 );
  FDistractorLimit := Value;
end;

procedure TMatchQuestion.SetPairLimit(Value: Integer);
begin
  Assert( Value >= 0 );
  FPairLimit := Value;
end;

class procedure TMatchQuestion.Spawn(var Question: TQuestion; Alterants: TAlterantList);
var
  Alterant: TSpawnMatchQuestionAlterant;
  MatchQuestion: TMatchQuestion;
  LeftItemsUsed, RightItemsUsed, i, n: Integer;
  LeftList, RightList: TIntegerList;
  Placement: TIntegerArray;
begin
  inherited;
  Assert( Question is TMatchQuestion );
  MatchQuestion := TMatchQuestion(Question);
  Assert( MatchQuestion.Right.Count >= MatchQuestion.Left.Count );
  Alterant := TSpawnMatchQuestionAlterant.Create;
  Alterants.Add(Alterant);

  LeftList := TIntegerList.Create;
  try
    for i := 0 to MatchQuestion.Left.Count-1 do
      LeftList.Add(i);
    RightList := TIntegerList.Create;
    try
      for i := MatchQuestion.Left.Count to MatchQuestion.Right.Count-1 do
        RightList.Add(i);

      if MatchQuestion.PairLimit = 0 then
        LeftItemsUsed := MatchQuestion.Left.Count
      else
        LeftItemsUsed := Min(MatchQuestion.PairLimit, MatchQuestion.Left.Count);
      for i := 1 to MatchQuestion.Left.Count - LeftItemsUsed do
      begin
        n := SecureRandomInteger(LeftList.Count);
        RightList.Add(LeftList[n]);
        LeftList.Delete(n);
      end;

      SetLength(Placement, LeftList.Count);
      for i := 0 to High(Placement) do
        Placement[i] := LeftList[i];
      Alterant.SetLeftPlacement(Placement);

      if MatchQuestion.DistractorLimit = 0 then
        RightItemsUsed := MatchQuestion.Right.Count
      else if MatchQuestion.DistractorLimit > 0 then
        RightItemsUsed := Min(LeftItemsUsed + MatchQuestion.DistractorLimit, MatchQuestion.Right.Count)
      else
        RightItemsUsed := LeftItemsUsed;

      { Remove excess distractors from RightList. }
      for i := 1 to RightList.Count - (RightItemsUsed - LeftList.Count) do
        RightList.Delete(SecureRandomInteger(RightList.Count));

      { Make distractor indices negative. }
      for i := 0 to RightList.Count-1 do
        RightList[i] := -RightList[i]-1;

      { Add correct items to RightList. }
      for n in LeftList do
        RightList.Add(n);

      ShuffleList(RightList, SecureRandomInteger);

      SetLength(Placement, RightList.Count);
      for i := 0 to High(Placement) do
        Placement[i] := RightList[i];
      Alterant.SetRightPlacement(Placement);
    finally
      RightList.Free;
    end;
  finally
    LeftList.Free;
  end;

  Alterant.Apply(Question);
end;

class function TMatchQuestion.Kind: TKind;
begin
  Result := $77b8a901b2d806dc;
end;

{ TMatchResponse }

function TMatchResponse.GetAnswer: TIntegerArray;
begin
  Result := Copy(FAnswer);
end;

procedure TMatchResponse.Assign(Source: TResponse);
begin
  inherited;
  FAnswer := Copy((Source as TMatchResponse).FAnswer);
  Changed;
end;

procedure TMatchResponse.SetAnswer(const Value: TIntegerArray);
begin
  FAnswer := Copy(Value);
  Changed;
end;

{ TSpawnMatchQuestionAlterant }

function CompareItemIndices(const a, b: TOfferedRightItem): Integer;
begin
  Result := CompareIntegers(a.FItemIndex, b.FItemIndex);
end;

procedure TSpawnMatchQuestionAlterant.Apply(var Question: TQuestion);
var
  MatchQuestion: TMatchQuestion;
  Answer: TIntegerArray;
  i, n: Integer;
  NewItems: TPadGroup;
  Items: TOfferedRightItemList;
begin
  Assert( Question is TMatchQuestion );
  MatchQuestion := TMatchQuestion(Question);
  Assert( Length(FRightPlacement) >= Length(FLeftPlacement) );

  NewItems := TPadGroup.Create;
  try
    for i := 0 to High(FLeftPlacement) do
      NewItems.Add(MatchQuestion.Left[FLeftPlacement[i]].Clone);
    MatchQuestion.Left.Assign(NewItems);

    NewItems.Clear;
    for i := 0 to High(FRightPlacement) do
    begin
      n := FRightPlacement[i];
      if n < 0 then
        n := -n-1;
      NewItems.Add(MatchQuestion.Right[n].Clone);
    end;
    MatchQuestion.Right.Assign(NewItems);
  finally
    NewItems.Free;
  end;

  Items := TOfferedRightItemList.Create;
  try
    for i := 0 to High(FRightPlacement) do
      Items.AddSafely(TOfferedRightItem.Create(i, FRightPlacement[i]));

    Items.Sort(CompareItemIndices);

    SetLength(Answer, Length(FLeftPlacement));
    n := Items.Count - Length(FLeftPlacement);
    for i := 0 to High(Answer) do
      Answer[i] := Items[n+i].FDisplayIndex;
    MatchQuestion.Response.SetAnswer(Answer);
  finally
    Items.Free;
  end;
end;

function TSpawnMatchQuestionAlterant.GetLeftPlacement: TIntegerArray;
begin
  Result := Copy(FLeftPlacement);
end;

function TSpawnMatchQuestionAlterant.GetRightPlacement: TIntegerArray;
begin
  Result := Copy(FRightPlacement);
end;

procedure TSpawnMatchQuestionAlterant.SetLeftPlacement(
  const Value: TIntegerArray);
begin
  FLeftPlacement := Copy(Value);
end;

procedure TSpawnMatchQuestionAlterant.SetRightPlacement(
  const Value: TIntegerArray);
begin
  FRightPlacement := Copy(Value);
end;

end.
